#!/usr/bin/perl

######################################################################
package Swignition::HtmlParser;
######################################################################

use Encode;
use HTML::Entities qw(:DEFAULT encode_entities_numeric %entity2char);
use HTML::Tagset;
use HTML::TreeBuilder;
use LWP::UserAgent;
use Swignition::GenericParser;
use utf8;
use strict;

use vars qw(@ISA);
@ISA = qw(Swignition::GenericParser);

sub new
{
	my $class    = shift;
	my $source   = shift;
	my $opts     = shift;
	my $this     = Swignition::GenericParser::object_structure($source, $opts);
	
	bless $this, $class;	

	# Infrastructure stuff
	$this->build_dom_tree;
	$this->find_base_uri;
	Swignition::GenericParser::Utils::PrepareXPointers($this->{DOM});
	Swignition::GenericParser::Utils::PrepareXmlLang($this->{DOM}->documentElement, undef, $opts->{response});
	$this->find_namespaces;
	$this->find_page_profiles;

	$this->{RDF}->{ $this->uri } = Swignition::RDFModel::Subject->new($this->uri);

	# Parse metadata automatically if that option is enabled.
	if ($this->{options}->{p_AUTO})
	{		
		no strict 'refs';
		
		# Note: do HTTP first as we use it to find additional metadata profiles!
		foreach my $module (qw(HTTP Metadata RoleAttr RDFa eRDF DocModel
			OpenCalaisML RDF::Embedded RDF::Comment GRDDL Recursive))
		{
			my $is_enabled = 'Swignition::GenericParser::'.$module.'::is_enabled';
			my $consume    = 'Swignition::GenericParser::'.$module.'::consume';
			&{$consume}($this) if &{$is_enabled}($this);
		}
	
		if ($this->{options}->{p_uf})
		{
			foreach my $module (qw(hCard adr geo XFN RelTag RelLicense RelEnclosure
				hCalendar hAtom COinS species hMeasure hReview hResume figure hAudio
				hRecipe))
			{
				my $consume    = 'Swignition::uF::'.$module.'::consume';
				&{$consume}($this);
			}
		}
		
		use strict 'refs';
	
		$this->smush;
	}

	return $this;	
}


sub build_dom_tree
{
	my $this = shift;

	# XML::LibXML parser.
	$Swignition::GenericParser::XDP = XML::LibXML->new();
	
	# Attempt to parse.
	eval {
		$this->{DOM} = $Swignition::GenericParser::XDP->parse_string($this->{Source});
	};
	
#	# If parsing failed, then 
#	if (! $this->{DOM} )
#	{
#		# Attempt to parse.
#		eval {
#			$this->{DOM} = $Swignition::GenericParser::XDP->parse_html_string($this->{Source});
#		};
#	}
	
	# If parsing failed, then 
	if (! $this->{DOM} )
	{
		$this->{_raw_source} = $this->{Source};
		
		# Figure out encoding.
		my $enc = 'iso-8859-1';
		if (($this->{RESPONSE} && $this->{RESPONSE}->header('content-type') =~ /\bcharset=[\"\'\s]?([a-z0-9-]+)/i)
		|| substr($this->{Source},0,2048) =~ /\bencoding=[\"\'\s]?([a-z0-9-]+)/i 
		|| substr($this->{Source},0,2048) =~ /\bcharset=[\"\'\s]?([a-z0-9-]+)/i )
			{ $enc = lc($1); }
		
		# Decode into UTF-8.
		if ($enc ne 'utf-8')
		{
			$this->{decoded_from} = $enc;
			$this->{Source} = decode($enc, $this->{Source});
		}

		# Try parsing again.
		if (!eval {
			$this->{DOM} = $Swignition::GenericParser::XDP->parse_string($this->{Source});
		})
		
		# If it still fails, then
		{
			# Last ditch attempt at getting this into usable XHTML...
			$this->{Source} = $this->html2xhtml($this->{Source});
			
			# If we can't parse it yet, then die.
			if (!eval {
				$Swignition::GenericParser::XDP->validation(0);
				$Swignition::GenericParser::XDP->recover(1);
				$Swignition::GenericParser::XDP->no_network(1);
				$this->{DOM} = $Swignition::GenericParser::XDP->parse_string($this->{Source});
			})
			{
				print "COULD NOT PARSE!\n";
				die;
			}
		}
	}	
}


sub find_base_uri
{
	my $this = shift;

	$this->{BASE} = $this->{RESPONSE}->base()
		if ($this->{RESPONSE} && $this->{RESPONSE}->base());

	# HTML <base> element.
	my @bases = $this->{DOM}->getElementsByTagName('base');
	my $base;
	foreach my $b (@bases)
	{
		$base = $b->getAttribute('href')
			if (length $b->getAttribute('href'));
	}
	$this->{BASE} = $this->uri($base)
		if (length $base);
}


sub find_namespaces
# Discover namespaces for metadata conforming to RFC 2731. Note
# that eRDF uses the same format for metadata schemas, so we
# can re-use these for eRDF too.
{
	my $this = shift;

	if ('Swignition::HtmlParser' eq ref $this)
	{
		# Pull out XML namespaces defined on the root node. For RDFa, etc we'll
		# also read namespaces from other nodes, but not at this point.
		foreach my $a ($this->{DOM}->getDocumentElement->getAttributes)
		{
			my $k = $a->getName;
			my $v = $a->getValue;
			next unless $k =~ /^xmlns\:/i;
			$k =~ s/^xmlns\://i;
		
			$this->mergeNS($k, $v, "The '$k' Namespace", '', 0);
		}
		
		# Find custom RFC 2731 namespaces. FOAF and other stuff goes here.
		foreach my $l ($this->{DOM}->getElementsByTagName('link'))
		{
			my $rel = $l->getAttribute('rel');
			
			if ($rel =~ /^schema[\.\:]([A-Z_][A-Z0-9_-]*)$/i)
			{
				my $prefix = $1;
				my $url    = $this->uri($l->getAttribute('href'));
				my $title  = $l->getAttribute('title');
				
				$this->mergeNS($prefix, $url, ($title||"The '$prefix' Schema"), undef, 1);
			}
		}
	}

	# Well-known namespaces, some defined so that page authors can be lazy;
	# others defined so that I can be lazy in writing modules.	
	
	$this->mergeNS('_',        'bnode:///',                                   'Blank Nodes',                             -1, 0);
	$this->mergeNS('dc',       'http://purl.org/dc/elements/1.1/',            'Dublin Core 1.1',                         -1, 1);
	$this->mergeNS('dcmitype', 'http://purl.org/dc/dcmitype/',                'Dublin Core Types',                       -1, 1);
	$this->mergeNS('dcterms',  'http://purl.org/dc/terms/',                   'Dublin Core Terms',                       -1, 1);
	$this->mergeNS('earl',     'http://www.w3.org/WAI/ER/EARL/nmg-strawman#', 'EARL',                                    -1, 0);
	$this->mergeNS('earlx',    'http://buzzword.org.uk/rdf/xearl#',           'EARL Extension',                          -1, 0);
	$this->mergeNS('foaf',     'http://xmlns.com/foaf/0.1/',                  'Friend of a Friend',                      -1, 1);
	$this->mergeNS('h5',       'http://buzzword.org.uk/rdf/h5#',              'HTML5 Meta Tags',                         -1, 0);
	$this->mergeNS('ianalink', 'http://www.iana.org/assignments/relation/',   'IANA Link Types',                         -1, 0);
	$this->mergeNS('invalid',  'http://invalid.invalid/ns#',                  'Undefined Namespace',                     -1, 0);
	$this->mergeNS('iso8601',  'urn:iso:std:iso:8601#',                       'ISO 8601',                                -1, 0);
	$this->mergeNS('link',     'http://www.w3.org/2006/link#',                'Link Vocab',                              -1, 0);
	$this->mergeNS('lazylist', 'http://buzzword.org.uk/rdf/list-items/',      'List Items',                              -1, 0);
	$this->mergeNS('owl',      'http://www.w3.org/2002/07/owl#',              'OWL Web Ontology Language',               -1, 0);
	$this->mergeNS('rdf',      'http://www.w3.org/1999/02/22-rdf-syntax-ns#', 'RDF/XML Syntax Specification (Revised)',  -1, 0);
	$this->mergeNS('rdfs',     'http://www.w3.org/2000/01/rdf-schema#',       'RDF Vocabulary Description Language 1.0', -1, 0);
	$this->mergeNS('schema',   'urn:ietf:rfc:2731#',                          'RFC2731-Style Schema',                    -1, 1);
	$this->mergeNS('xhe',      'http://buzzword.org.uk/rdf/xhtml-elements#',  'XHTML Elements',                          -1, 0);
	$this->mergeNS('xhv',      'http://www.w3.org/1999/xhtml/vocab#',         'XHTML Vocabulary',                        -1, 0);
	$this->mergeNS('xsd',      'http://www.w3.org/2001/XMLSchema#',           'XML Schema',                              -1, 0);
}


sub find_page_profiles
{
	my $this = shift;
	
	foreach my $head ($this->{DOM}->getElementsByTagName('head'))
	{
		my $profile = $head->getAttribute('profile');
		$profile =~ s/(^\s+|\s+$)//g;
		foreach my $url (split /\s+/s, $profile)
		{
			$url = $this->uri($url);
			$this->{Profiles}->{ $url } = 1;
		}
	}
	
	foreach my $link (Swignition::GenericParser::Utils::searchRel('profile', $this->{DOM}))
	{
		my $url = $this->uri($link->getAttribute('href'));
		$this->{Profiles}->{ $url } = 1;
	}
}


sub html2xhtml
{
	my $this = shift;
	my $html = shift;
	
	$html =~ s/\<\!DOCTYPE[^>]*\>//i;
	
	# HTML 5 additional tags, not otherwise supported by HTML::TreeBuilder.
	foreach my $inline (qw(time mark meter progress output ruby rb rt rp rtc rbc))
	{
		$HTML::Tagset::isPhraseMarkup{$inline} = 1;
		$HTML::Tagset::is_Possible_Strict_P_Content{$inline} = 1;
		$HTML::Tagset::isBodyElement{$inline} = 1;
		$HTML::Tagset::isKnown{$inline} = 1;
	}
	$HTML::Tagset::isFormElement{'output'} = 1;
	foreach my $empty (qw(command source event-source)) # embed is already there
	{
		$HTML::Tagset::emptyElement{$empty} = 1;
		$HTML::Tagset::canTighten{$empty} = 1;
		$HTML::Tagset::isPhraseMarkup{$empty} = 1;
		$HTML::Tagset::is_Possible_Strict_P_Content{$empty} = 1;
		$HTML::Tagset::isBodyElement{$empty} = 1;
		$HTML::Tagset::isKnown{$empty} = 1;
	}
	$HTML::Tagset::isHeadElement{'event-source'} = 1;
	$HTML::Tagset::isHeadOrBodyElement{'event-source'} = 1;
	foreach my $object (qw(video audio canvas))
	{
		$HTML::Tagset::is_Possible_Strict_P_Content{$object} = 1;
		$HTML::Tagset::isBodyElement{$object} = 1;
		$HTML::Tagset::isKnown{$object} = 1;
	}
	foreach my $block (qw(section header footer article aside nav figure dialog details datagrid)) # menu is already there
	{
		push @HTML::Tagset::p_closure_barriers, $block;
		$HTML::Tagset::isBodyElement{$block} = 1;
		$HTML::Tagset::isKnown{$block} = 1;
	}
	
	my $t = HTML::TreeBuilder->new();
	$t->implicit_tags(1);
	$t->p_strict(1);
	$t->store_comments(1);
	$t->parse_content($html);
	$t->{'xmlns'} = 'http://www.w3.org/1999/xhtml';
	
	my $dtdPath = __FILE__;
	$dtdPath =~ s|HtmlParser.pm$|ext/sgml-lib/REC-xhtml1-20020801/xhtml1-transitional.dtd|;
	my $xhtml = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
		. "<!DOCTYPE html\n"
		. "\tPUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"\n"
		. "\t\"$dtdPath\">\n"
		. $t->as_XML(undef, "\t", {
			'area'=>1,
			'base'=>1,
			'basefont'=>1,
			'br'=>1,
			'col'=>1,
			'frame'=>1,
			'hr'=>1,
			'img'=>1,
			'input'=>1,
			'isindex'=>1,
			'link'=>1,
			'meta'=>1,
			'param'=>1,
			'command'=>1,
			'source'=>1,
			'event-source'=>1,
			'embed'=>1
		});

	# XHTML now has some annoying named entities.
	#my %ents = %HTML::Entities::entity2char;
	#foreach my $e (keys %ents)
	#{
	#	my $char = $ents{$e};
	#	$e =~ s/\;$//;
	#	$xhtml =~ s/ \& $e \; / sprintf "&#x%X;", ord($char) /gex;
	#}
	
	return encode_entities($xhtml, "\x80-\xFF");
	
	return $xhtml;
}

1;
